Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-03/qbs-0101.zip/FEATURE.QBS

Text File | 1993-01-04 | 31KB | 881 lines

------------------------------------------------------------------------
  The QuickBASIC Scrapbook                               Special Feature
                                                         ---------------
  Vol 1, Issue 1                                            January 1993
------------------------------------------------------------------------
   There are three parts to this special feature: Introduction,
 QuickBASIC code, and Assembler code. Special thanks to Rich
 Geldreich, who took many days to develop this code, then release
 it into the public domain. Thanks, Rich!


════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #13647
 Date:    11-30-92 21:12 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: Mod Player                                      (Introduction)
────────────────────────────────────────────────────────────────────────

    Due to the fact the Cornel Huth will be releasing a Shareware MOD
player in the very near future, I have decided to flood the QuickBASIC
information net's with as much MOD playing code/information as possible.
The following messages contain a working MOD player written in almost
pure-QB, the ASM module takes care of PC-Speaker control, which QB is
not good at.

    The QB code is documented, so it shouldn't be too hard to follow.
Sorry, the ASM code is still a little bare.

    Sound Blaster and other soundcards can be supported by making
modifications to the ASM buffer player. I will post these mods if anyone
is interested in them.

    Rich


    PS. I will do my best to optimize the ASM version of this player so
it can be small enough to post on this conference.

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)

════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #13648 - #13654
 Date:    11-30-92 21:14 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: MOD Player: QuickBASIC version
────────────────────────────────────────────────────────────────────────────────
'QBMP15.BAS (experiment 26-parallel substager/mixer & looping overmix)
'A PDS/QB4.5 4-Channel Amiga MOD Player
'Written by Rich Geldreich (C) Copyright November 27, 1992
'You may use this program for anything you wish, but if you're going to
'make any money off it I would like to know about it first.
'
'NOTES: This program also requires INTRPT.OBJ (from QB.LIB or QBX.LIB),
'and QBMPASM.ASM to function. I have only tested this program in
'PDS 7.1. I *highly* recommend that you only run this program compiled!
'
'To compile(this is a pretty complicated procedure for beginners):
'-First, you must extract INTRPT.OBJ from QB.LIB or QBX.LIB(depending
'-on QB/BC7). Type:
'LIB QBX.LIB *INTRPT.OBJ,;              [BC7]
'LIB QB.LIB *INTRPT.OBJ,;               [QB4.5]
'-Then make a QLB by:
'LINK /q QBMPASM+INTRPT,,,QBXQLB,;      [BC7]
'LINK /q QBMPASM+INTRPT,,,BQLB45        [QB4.5]
'-And a LIB by:
'LIB QBMPASM QBMPASM+INTRPT,;           [BC7 or QB4.5]
'-Then load QB(or QBX) with the following and compile:
'QB(x) /lQBMPASM QBMP15
'Please note that the above instructions for QB4.5 haven't been tested.
'
'If you have a fast computer and want better sound change the variable
'"IntRate=11000" below to a larger number(max is about 19,000 hz). This
'program is currently configured to load MODs up to about 300k, change
'the line that says "Null& = SETMEM(-300000)" to load larger MODs.
'Anyone having problems or questions and can afford a L/D call:
'(609)-742-8752 between 3:00pm and 1:00am eastern time.
'
'If you get it compiled successfully, then run it with:
'QBMP15 modfile.MOD
'You should hear the MOD play on your PC-Speaker. The keys 1-4 turn
on/off
'each channel, and the left and right arrows fast forward/rewind the
MOD.
'Press escape to drop back to DOS. Here goes!! -RG
DEFINT A-Z
CONST True = -1, False = 0
DECLARE FUNCTION CheckDoneFlag% ()
DECLARE SUB SetBuffers (BYVAL BDS%, BYVAL Buffer1%, BYVAL Buffer2%, _
BYVAL BufferSize%)
DECLARE FUNCTION GetCS% ()
DECLARE FUNCTION GetOF% ()
DECLARE FUNCTION UnsignedComp% (BYVAL A%, BYVAL B%)

DECLARE SUB SetInt8Rate (A&)
DECLARE SUB SpeakerOff ()
DECLARE SUB SpeakerOn ()
DECLARE FUNCTION Alloc% (A%)
DECLARE SUB ExitWithError (A$)
DECLARE FUNCTION Extract% (A$, offset%)

TYPE RegTypeX
     ax    AS INTEGER
     bx    AS INTEGER
     cx    AS INTEGER
     dx    AS INTEGER
     bp    AS INTEGER
     si    AS INTEGER
     di    AS INTEGER
     flags AS INTEGER
     ds    AS INTEGER
     es    AS INTEGER
END TYPE
DIM SHARED CPU as RegTypeX

'Sample arrays.
DIM S.Name(30) AS STRING * 22
DIM S.Volume(30)
DIM S.Segment(30)
DIM S.RepStart(30),     S.RepLength(30)
DIM S.Length(30)

'Channel arrays
DIM C.InactiveFlag(3)
DIM C.Volume(3)
DIM C.Segment(3)
DIM C.Period(3),        C.HighStep(3),  C.LowStep(3)
DIM C.Offset(3),        C.Remainder(3)
DIM C.RepStart(3),      C.RepLength(3), C.LoopEnd(3)
DIM C.Length(3)

'For command processing
DIM C.Command(3)
DIM C.PortSpeed(3)
DIM C.PortDest(3)
DIM C.VolumeSpeed(3)

'Misc. Arrays
DIM PeriodHigh(1023),   PeriodLow(1023) 'Precalculated step rates
DIM VolumeTable(63, 255) 'Precalculated volume tables
DIM SampleBuffer(1199)   'Sample buffer;for mixing+playing at same time.
DIM PatternSegment(127)  'Holds segment's of all the patterns to play
DIM ActiveChannels(3)    'Holds active channels while mixing
DIM ChannelOn(3)

DIM Scale8to6(255)       'translation table for dividing each signed
                         'sample by 4
'=====================================================================
ON ERROR GOTO ErrorHandler

PRINT "QBMP v1.5 - An Amiga MOD player written in PDS/QuickBASIC."
PRINT "(C) Copyright 1992 By Rich Geldreich"
'Precalculate an 8-bit to 6-bit signed translation table
FOR A=-128 to 127
    C=A\4
    IF A<0 then Scale8to6(A+256)=C ELSE Scale8to6(A)=C
NEXT

'Free up 300,000 bytes of far memory.
Null& = SETMEM(-300000)

FileSpec$ = Command$
IF INSTR(FileSpec$,".")=0 THEN FileSpec$=FileSpec$+".MOD"
'Attempt to open the MOD file.
OPEN FileSpec$ FOR INPUT AS #1:CLOSE #1
OPEN FileSpec$ FOR BINARY AS #1

'Check to see if MOD contains 15 or 31 samples...
A$ = "    ": GET #1, 1081, A$
'If the string at offset 1081 is "M.K.", or the first 3 letters are
'"FLT", then the MOD contains 31 samples:
S.Max = 15 - 16 * ((A$ = "M.K.") OR (LEFT$(A$, 3) = "FLT"))

'Print the MOD's title
A$ = SPACE$(20): GET #1, 1, A$
PRINT "Title: ";A$
'=====================================================================
A$ = SPACE$(8)
FOR A = 0 TO S.Max - 1
    'Skip the sample's name
    GET #1, , S.Name(A)
    'Get the info on the sample
    GET #1, , A$
    S.Volume(A)         = ASC(MID$(A$, 4, 1))
    IF S.Volume(A) > 64 THEN S.Volume(A) = 64
    S.Length(A)         = Extract(A$, 1)
    S.RepStart(A)       = Extract(A$, 5)
    S.RepLength(A)      = Extract(A$, 7)
    IF S.RepLength(A) = 2 THEN S.RepLength(A) = 0
    IF S.Length(A)=2 THEN S.Length(A)=0
NEXT
'=====================================================================
A$ = " ": GET #1, , A$: T.Length = ASC(A$): GET #1, , A$
'Load the pattern table.
HighestPattern = -1
FOR A = 0 TO 127
    GET #1, , A$: B = ASC(A$)
    IF B > HighestPattern THEN HighestPattern = B
    PatternSegment(A) = B
NEXT
'=====================================================================
IF S.Max = 31 THEN SEEK #1, LOC(1) + 5
A$ = SPACE$(1024)
'Load the patterns.
FOR A = 0 TO HighestPattern
    LOCATE , 1: PRINT USING "Parsing Pattern ##"; A;
    GET #1, , A$
    B = Alloc(80): DEF SEG = B: C = 0

    e = 1
    FOR d = 1 TO 256
        b1 = ASC(MID$(A$, e, 1))
        b2 = ASC(MID$(A$, e + 1, 1))
        b3 = ASC(MID$(A$, e + 2, 1))
        b4 = ASC(MID$(A$, e + 3, 1))
        e = e + 4
        sample = (b1 AND 240) OR (b3 \ 16)
        period = (b1 AND 15) * 256 OR b2
        effect = b3 AND 15
        operand = b4

        IF sample > S.Max THEN sample = 0
        IF period > 1023 OR period < 20 THEN period = 0

        SELECT CASE effect
        CASE &HC
            IF operand > 64 THEN operand = 64
        END SELECT
        'Store the channel in an expanded format for ease of processing.
        POKE C, sample
        POKE C + 1, period \ 256
        POKE C + 2, period AND 255
        POKE C + 3, effect
        POKE C + 4, operand
        C = C + 5
    NEXT
    'Fill in the pattern's segment in the position table.
    FOR d = 0 TO 127:IF PatternSegment(d)=A THEN PatternSegment(d)=B
    NEXT
NEXT
'=====================================================================
'Load the samples.
FOR A = 0 TO S.Max - 1
    LOCATE , 1: PRINT USING "Loading Sample ##  "; A + 1;

    d& = S.Length(A): IF d& < 0 THEN d& = d& + 65536
    'Allocate 1024 bytes more than needed for mixer runoff.
    d& = d& + 1024
    IF d& > 65530 THEN ExitWithError "Sample Too Large"

    B = Alloc(d& \ 16 + 1) 'Allocate memory for the sample.
    S.Segment(A) = B

    'Load the sample
    CPU.ax = &H3F00
    CPU.bx = FILEATTR(1, 2)
    CPU.ds = B: CPU.dx = 0
    CPU.cx = S.Length(A)

    CALL interruptx(&H21, CPU, CPU)
    IF (CPU.Flags AND 1) THEN ExitWithError "Error Loading Sample"

    DEF SEG = B

    A& = S.Length(A): IF A& < 0 THEN A& = A& + 65536

    'Divide each byte of the sample by 4 for mixing. A lookup table is
    'used because QB doesn't support signed bytes.
    FOR B& = 0 TO A& - 1
        POKE B&, Scale8to6(PEEK(B&))
    NEXT

    'Clear the end of the sample for mixer runoff.
    FOR A& = A& TO A& + 1023
        POKE A&, 0
    NEXT
NEXT
'=====================================================================
LOCATE ,1:PRINT SPACE$(40);

IntRate = 11000      'Interrupt speed, in samples per second.

'Figure out how many samples per 1/50th of a second.
IntsPerClick = IntRate \ 50

'Precalculate a step for each period. The constant &H369040 is from the
'Amiga, it is scaled up by 256 (&h100) so floating point math can be
'eliminated.
K& = &H36904000 \ IntRate
FOR A = 20 TO 1023
    A& = K& \ A
    PeriodHigh(A) = A& \ 256
    PeriodLow(A) = CINT(A&) AND 255
NEXT
'Precalculate the volume lookup tables. Enables the mixer to adjust the
'volume of a sample with slow multiples and divides.
FOR A = 0 TO 63
    FOR B = -128 TO -1
        C = (B * A) \ 64: IF C < 0 THEN C = C + 256
        VolumeTable(A, B + 256) = C
    NEXT
    FOR B = 0 TO 127
        VolumeTable(A, B) = (B * A) \ 64
    NEXT
NEXT

'Make all channels inactive, and enable them.
FOR A = 0 TO 3: C.InactiveFlag(A) = True: ChannelOn(A)=True:NEXT

BufferOffset    = 512   'Current mixing offset.
T.Tempo         = 6     'Default tempo is 6/50th of a second.
T.ClicksLeft    = 6     'Clicks left before a line.
T.Pos           = 0     'Lines left before a new pattern.
GOSUB StartNewPattern
GOSUB DoLine

DEF SEG=&H0
'Save old interrupt 8 handler.
CPU.ax = &H3508:CALL interruptx(&H21, CPU, CPU)
Old8.Offset = CPU.bx:Old8.Segment = CPU.es
'Initialize the assembly buffer player.
SetBuffers VARSEG(SampleBuffer(0)), VARPTR(SampleBuffer(0)), _
           VARPTR(SampleBuffer(512)), IntsPerClick * 2

'Set int 8 to our asm routine
CPU.ax = &H2508:CPU.ds = GetCS:CPU.dx = GetOF
CALL interruptx(&H21, CPU, CPU)

'Reprogram the 8255's timer to the specified sample rate.
SetInt8Rate &H1234DE \ IntRate

'Turn speaker on, and play the MOD.
SpeakerOn
DO

    'Wait for sync signal from the assembly buffer player...
    DO: LOOP UNTIL CheckDoneFlag

    'Mix another buffer.
    GOSUB DoMix

    A$=INKEY$
    IF A$<>"" THEN  'Process any keystrokes.
        K=ASC(RIGHT$(A$,1))
        SELECT CASE K
        CASE 49 TO 52
             ChannelOn(K-49) = NOT ChannelOn(K-49)
        CASE 27
             Exit do
        CASE &H4b 'Left
            T.Pos=T.Pos-1
            IF T.Pos<0 THEN T.Pos=T.Length-1
            GOSUB StartNewPattern
        CASE &H4d 'Right
            T.Pos=T.Pos+1
            IF T.Pos=>T.Length THEN T.Pos=0
            GOSUB StartNewPattern
        END SELECT
   END IF

LOOP
'Turn off speaker.
SpeakerOff
'Set int 8 rate to normal (18.2 hz)
SetInt8Rate 0

'restore old int 8 handler
CPU.ax = &H2508:CPU.ds = Old8.Segment:CPU.dx = Old8.Offset
CALL interruptx(&H21, CPU, CPU)

LOCATE ,1:PRINT SPACE$(40);
END
'=====================================================================
'Processes 1 line(4 channels) of a pattern.
DoLine:
    DEF SEG = PatternSegment

    FOR A = 0 TO 3
        C = PEEK(T.Offset): T.Offset = T.Offset + 1

        IF C <> 0 THEN  'Process a new sample, if any.
            C = C - 1
            C.Segment(A)        = S.Segment(C)
            C.Volume(A)         = S.Volume(C)
            C.RepStart(A)       = S.RepStart(C)
            C.RepLength(A)      = S.RepLength(C)
            C.Length(A)         = S.Length(C)
            C.LoopEnd(A)        = C.Length(A)
        END IF

        C = PEEK(T.Offset) * 256 + PEEK(T.Offset + 1)
        T.Offset = T.Offset + 2
        IF C <> 0 THEN  'Process a new period, if any.
            IF PEEK(T.Offset) <> 3 THEN
                C.Period(A)     = C
                C.HighStep(A)   = PeriodHigh(C) 'Lookup the step rate of
                C.LowStep(A)    = PeriodLow(C)  'the new period.
                C.Offset(A)     = 0
                C.LoopEnd(A)    = C.Length(A)
                C.Remainder(A)  = -256
                C.InactiveFlag(A) = False
            END IF
        END IF

        C.Command(A) = 0
        M = PEEK(T.Offset)
        IF M<>0 THEN    'Process a command, if any.
            o = PEEK(T.Offset + 1)
            SELECT CASE M
            CASE 12             'Volume
                C.Volume(A) = o
            CASE 15             'Tempo
                T.Tempo = o
            CASE 1              'Port Down
                C.Command(A)   = 2
                C.PortSpeed(A) = O
            CASE 2              'Port Up
                C.Command(A)   = 3
                C.PortSpeed(A) = O
            CASE 3              'Port to Note
                IF C.Period(A) > C THEN
                    C.Command(A) = 4
                ELSE
                    C.Command(A) = 5
                END IF
                C.PortSpeed(A) = o
                C.PortDest(A)  = C
            CASE 10             'Volume Slide
                C.Command(A) = 1
                IF O AND 15 THEN
                    C.VolumeSpeed(A) = -(O AND 15)
                ELSE
                    C.VolumeSpeed(A) = O\16
                END IF
            CASE 11             'Position Jump
                IF o<T.Length THEN
                    T.Pos = o
                    T.Line = 1
                END IF
            CASE 13             'Pattern Skip
                T.Line = 1
            END SELECT
        END IF
        T.Offset = T.Offset + 2
    NEXT
    T.ClicksLeft = T.Tempo
    T.Line = T.Line - 1:IF T.Line = 0 THEN GOTO NewPattern
RETURN
NewPattern:
    T.Pos = T.Pos + 1:IF T.Pos >= T.Length THEN T.Pos = 0
    GOSUB StartNewPattern
RETURN
StartNewPattern:
    LOCATE ,1
    PRINT USING "Playing:###"; (T.Pos*100&)\T.Length;
    PRINT "%";
    T.Line              = 64
    PatternSegment      = PatternSegment(T.Pos)
    T.Offset            = 0
RETURN
'=====================================================================
'Main mixer follows. While the assembly routine is playing one buffer,
'this routine mixes the other.
DoMix:
    BufferOffset = BufferOffset XOR 512

    Tm=0
    FOR K = 0 TO 3
        IF C.InactiveFlag(K)=False AND ChannelOn(K) THEN
            GOSUB Mix
            Tm = 1
        END IF
    NEXT
    If Tm=0 then 'If all channels inactive then just clear buffer to
0's.
        FOR B = BufferOffset TO BufferOffset + IntsPerClick-1
            SampleBuffer(B) = 0
        NEXT
    END IF

    T.ClicksLeft = T.ClicksLeft - 1
    'If not time for a new line the process slide commands, if any.
    IF T.ClicksLeft = 0 THEN GOSUB DoLine ELSE GOSUB DoCommands
RETURN
'=====================================================================
Mix:
    MixesLeftToDo   = IntsPerClick
    OffsetNow       = BufferOffset

    'Preload all needed variables for speed.
    DEF SEG = C.Segment(K)
    o = C.Offset(K)                     'current offset into sample
    r = C.Remainder(K)                 'current remainder(0-255) at
offset
    v = C.Volume(K)                     'volume(0-64)

    h = C.HighStep(K)                   'integer step
    l = C.LowStep(K)                    'remainder step(0-255)

    IF C.RepLength(K) THEN
        DO
         'If sample loops the calculate the number of mixes left until
         'we must loop...
            PL&=C.LoopEnd(K)-o

         'Thanks to QB's lack of unsigned ints, we must do this...
            IF PL&<0 THEN PL&=PL&+65536
            MixesTillRepeat& = (PL& * 256 - (r+256)) \ ((h * 256&) + l)

         'If there is any remainder left, then add 1 to MixesTillRepeat.
            IF ( (PL& * 256 - (r+256)) MOD ((h * 256&) + l) ) THEN
                MixesTillRepeat&=MixesTillRepeat&+1
            END IF

            IF MixesLeftToDo >= MixesTillRepeat& THEN
                MixesToDo      = MixesTillRepeat&
    )    'for next loop.
                    C.LoopEnd(K) = C.RepStart(K) + C.RepLength(K)
                ELSE
                    o            = o - C.RepLength(K)
                ENDIF
            ELSE
                EXIT DO
            END IF
        LOOP
    END IF

    'Mix whatever is left.
    MixesToDo = MixesLeftToDo
    Gosub LowLevelMix

    'Store back the offset and its remainder.
    C.Offset(K) = o
    C.Remainder(K) = r

    'If sample doesn't loop, and the offset passed the end of the
sample,
    'then turn off the channel.
    IF C.RepLength(K) = 0 AND UnsignedComp(o, C.Length(K)) > 0 THEN
        C.InactiveFlag(K) = True
    END IF
RETURN

LowLevelMix:
    'Copies the samples from the instruments to the mixing buffer.
    'If this is the first copy (Tm=0), then just store the sample,
    'otherwise add it into the buffer.
    If Tm=0 then
        'Since most channels will have a volume of 64 (max), then only
        'use the volume lookup table (which is slow) when needed...
        IF v <> 64 THEN
            FOR OffsetNow = OffsetNow TO OffsetNow + MixesToDo - 1
                SampleBuffer(OffsetNow) = VolumeTable(v, PEEK(o))
                o = o + h
                'If remainder overflows, then increment the offset by 1
                'and adjust the remainder back down.
                r = r + l: IF r => 0 THEN r = r - 256: o = o + 1
            NEXT
        ELSE
            FOR OffsetNow = OffsetNow TO OffsetNow + MixesToDo - 1
                SampleBuffer(OffsetNow) = PEEK(o)
                o = o + h
                r = r + l: IF r => 0 THEN r = r - 256: o = o + 1
            NEXT
        END IF
    ELSE
        IF v <> 64 THEN
            FOR OffsetNow = OffsetNow TO OffsetNow + MixesToDo - 1
                SampleBuffer(OffsetNow) = SampleBuffer(OffsetNow) + _
VolumeTable(v, PEEK(o))
                o = o + h
                r = r + l: IF r => 0 THEN r = r - 256: o = o + 1
            NEXT
        ELSE
            FOR OffsetNow = OffsetNow TO OffsetNow + MixesToDo - 1
                SampleBuffer(OffsetNow)=SampleBuffer(OffsetNow)+PEEK(o)
                o = o + h
                r = r + l: IF r => 0 THEN r = r - 256: o = o + 1
            NEXT
        END IF
    END IF
RETURN
'=====================================================================
'Process the MOD sliding commands...
DoCommands:
    FOR A=0 TO 3
        IF C.Command(A) THEN
            SELECT CASE C.Command(A)
            CASE 1                      'Volume slide
                C.Volume(A)=C.Volume(A)+C.VolumeSpeed(A)
                IF C.Volume(A)<0 THEN
                    C.Volume(A)=0
                    C.Command(A)=0
                ELSEIF C.Volume(A)>64 THEN
                    C.Volume(A)=64
                    C.Command(A)=0
                END IF
            CASE 2                      'Port down
                C.Period(A) = C.Period(A) - C.PortSpeed(A)
                IF C.Period(A)<113 THEN
                    C.Period(A)  = 113
                    C.Command(A) = 0
                END IF
                C.HighStep(A)   = PeriodHigh(C.Period(A))
                C.LowStep(A)    = PeriodLow(C.Period(A))
            CASE 3                      'Port up
                C.Period(A) = C.Period(A) + C.PortSpeed(A)
                IF C.Period(A)>1023 THEN
                    C.Period(A) = 1023
                    C.Command(A) = 0
                END IF
                C.HighStep(A)   = PeriodHigh(C.Period(A))
                C.LowStep(A)    = PeriodLow(C.Period(A))
            CASE 4                      'Port to Note Down
                C.Period(A) = C.Period(A) - C.PortSpeed(A)
                IF C.Period(A) <= C.PortDest(A) THEN
                    C.Period(A) = C.PortDest(A)
                    C.Command(A) = 0
                END IF
                C.HighStep(A)   = PeriodHigh(C.Period(A))
                C.LowStep(A)    = PeriodLow(C.Period(A))
            CASE 5                      'Port to Note Up
                C.Period(A) = C.Period(A) + C.PortSpeed(A)
                IF C.Period(A) >= C.PortDest(A) THEN
                    C.Period(A) = C.PortDest(A)
                    C.Command(A) = 0
                END IF
                C.HighStep(A)   = PeriodHigh(C.Period(A))
                C.LowStep(A)    = PeriodLow(C.Period(A))
            END SELECT
        END IF
    NEXT
RETURN
'=====================================================================
'Allocates memory from DOS.
FUNCTION Alloc (A)
    CPU.ax = &H4800
    CPU.bx = A
    CALL interruptx(&H21, CPU, CPU)
    IF (CPU.Flags AND 1) THEN ExitWithError "Out of Memory"
    Alloc = CPU.ax
END FUNCTION
'=====================================================================
SUB ExitWithError (A$)
    IF POS(0) <> 1 THEN PRINT
    PRINT A$: END
END SUB
'=====================================================================
'Extracts a Motorola word from a string, and multiples it by 2.
FUNCTION Extract% (A$, offset)
    v& = (512&*ASC(MID$(A$,offset,1))+ASC(MID$(A$,offset+1, 1)) * 2&)
    IF v& > 65535 THEN ExitWithError "Sample Too Large"
    IF v& > 32767 THEN v& = v& - 65536
    Extract% = v&
END FUNCTION
'=====================================================================
'Reprograms the 8255 timer so it hits an int 8 at a different rate.
SUB SetInt8Rate (A&)
    OUT &H42, 2 + 4 + 16 + 32
    OUT &H40, CINT(A&) AND 255
    OUT &H40, A& \ 256
END SUB
'=====================================================================
SUB SpeakerOff
    OUT &H61, INP(&H61) AND 252
END SUB
'=====================================================================
SUB SpeakerOn
    OUT &H61,INP(&H61) OR 3:OUT &H43,128+32+16:OUT &H42,0
    OUT &H42,0:OUT &H43,128+16
END SUB
'=====================================================================
ErrorHandler:
    SELECT CASE ERR
    CASE 7
        ExitWithError "Out of Memory Error"
    CASE 52, 53, 68
        ExitWithError "Bad File Name/File not found"
    CASE ELSE
        ExitWithError "Fatal Error"+STR$(ERR)+" has occured!"
    END SELECT
'END OF QBMP15.BAS====================================================

'QBS Comments: QuickBASIC version complete!


════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #13655
 Date:    11-30-92 21:20 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: PCSpkr MOD - Assembler Code
────────────────────────────────────────────────────────────────────────────────
;QBMPASM.ASM (Misc. ASM & PC-Speaker routines for QBMP15.BAS)
;Written by Rich Geldreich (C) Copyright November 27, 1992
;Assembled with TASM v2.0 (This module hasn't been documented yet.)
IDEAL
MODEL SMALL
CODESEG
PUBLIC  CheckDoneFlag, SetBuffers, GetCS, GetOF, UnsignedComp
EVEN
ASSUME cs:@CODE, ds:@CODE, es:NOTHING, ss:@DATA
;=====================================================================
Buffer1  dw 0
Buffer2  dw 0
DoneFlag db 0
XLATTable: ;PC-Speaker LOG table
db 32,31,30,29,28,27,26,25,24,24,23,23,22,22,21,21,21,20,20,20,19,19,19
db 18,18,18,18,17,17,17,17,16,16,16,16,15,15,15,15,14,14,14,14,14,13,13
db 13,13,13,12,12,12,12,12,11,11,11,11,11,11,10,10,10,10,10,10,9,9,9,9
db 9,9,8,8,8,8,8,8,7,7,7,7,7,7,7,6,6,6,6,6,6,6,5,5,5,5,5,5,5,4,4,4,4,4
db 4,4,3,3,3,3,3,3,3,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,65,65,65,65,65,65,65
db 64,64,64,64,64,64,64,63,63,63,63,63,63,63,62,62,62,62,62,62,62,61,61
db 61,61,61,61,61,60,60,60,60,60,60,60,59,59,59,59,59,59,59,58,58,58,58
db 58,58,57,57,57,57,57,57,56,56,56,56,56,56,55,55,55,55,55,55,54,54,54
db 54,54,53,53,53,53,53,52,52,52,52,52,51,51,51,51,50,50,50,50,49,49,49
db 49,48,48,48,48,47,47,47,46,46,46,45,45,45,44,44,43,43,42,42,41,40,39
db 38,37,36,35,34,33
;=====================================================================
EVEN
PROC    NewInt8
        Push    ds ax bx
BDS     = $+1
        Mov     ax, 09999h
        Mov     ds, ax
Offset8 = $+1
        Mov     bx, 09999h
        Mov     al, [ds:bx]
        Inc     bx
        Inc     bx
        Mov     [word cs:Offset8], bx
End8    = $+2
        Cmp     bx, 09999h
        Je      @@10
@@Back: Mov     bx, offset XLATTable
        Xlat    [cs:bx]
        Out     042h, al
        Mov     al, 020h
        Out     020h, al
        Pop     bx ax ds
        Iret
EVEN
@@10:   Mov     [byte cs:DoneFlag], -1
        Mov     bx, [cs:Buffer1]
        Xchg    bx, [cs:Buffer2]
        Mov     [cs:Buffer1], bx
        Mov     [word cs:Offset8], bx
BufferSize = $+2
        Add     bx, 09999h
        Mov     [word cs:End8], bx
        Jmp     @@Back
ENDP    NewInt8
;=====================================================================
EVEN
PROC    CheckDoneFlag
        Xor     al, al
        Xchg    [cs:DoneFlag], al
        Cbw
        Retf    0
ENDP    CheckDoneFlag
;=====================================================================
PROC    SetBuffers  ;BDS Buffer1 Buffer2 BufferSize
;                     12   10       8        6
        Push    bp
        Mov     bp, sp
        Push    ds cs
        Pop     ds
        Mov     ax, [ss:bp+8]
        Mov     [ds:Buffer2], ax
        Mov     ax, [ss:bp+12]
        Mov     [word ds:BDS], ax
        Mov     ax, [ss:bp+10]
        Mov     [ds:Buffer1], ax
        Mov     [word ds:Offset8], ax
        Mov     bx, [ss:bp+6]
        Mov     [word ds:BufferSize], bx
        Add     ax, bx
        Mov     [word ds:End8], ax
        Pop     ds bp
        Retf    8
ENDP    SetBuffers
;=====================================================================
PROC    GetCS
        Mov     ax, cs
        Retf    0
ENDP    GetCS
;=====================================================================
PROC    GetOF
        Mov     ax, offset NewInt8
        Retf    0
ENDP    GetOF
;=====================================================================
PROC    UnsignedComp
        Push    bp
        Mov     bp, sp
        Mov     ax, [ss:bp+08]
        Cmp     ax, [ss:bp+06]
        Jae     @@AboveOrEqual
        Xor     ax, ax
@@Back: Pop     bp
        Retf    4
@@AboveOrEqual:
        Mov     ax, 1
        Jmp     @@Back
ENDP    UnsignedComp
;=====================================================================
END
'<<-Cut Here->>

════════════════════════════════════════════════════════════════════════════════
 Area:    QuickBasic
  Msg:    #13655
 Date:    11-30-92 21:20 (Public)
 From:    RICH GELDREICH
 To:      ALL
 Subject: PCSpkr MOD - OBJ of ASM code <=> DEBUG
───────────────────────────────────────────────────────────────────────────────

To execute this script, save it to a file and type DEBUG < filename
where "filename" is the name of this script file.
E165"QBMPASM.OBJ" 0
E200".q..92bMh/LMnpa9/BJHcVs5....IJbQWx46/BrQZpaMgJaQU.WJZ7rQdxaPU"
E23D"6X9kY9WH..EdTGEyZl0l7KPk3qQhtGEHpYA6C...ZCHK8...U4W1..EVGdZA."
E27A"E/TFJFMF3/1x2F3N7a5..Gc4U.12UOKm..3w3F/FJE2EIEI3YkMS..6/..2IE"
E2B7".DM70.M.F57pHJ/pWOG..4wj.P/73..E.BA2G3BoG2xYH3N2H/RYJ/.EKE4/."
E2F4".2U0HJ2J0JZF4JYIHxJ..gDYA.../IkF3FpEHhM..k3YA.../IkF3FpH4tM.."
E331"c3YH.../kEJCBJG5tIF2BoHB/ZY/.EA6G...7O.F08f/2..........UwV5Rk"
E36E"l4OY/4MQl3KMF3JI/3IEl2HAV2G6V2F2F2F./2E.l1Dwk1CsU1CsE1BoE1Bk."
E3AB"1Ak.19gk09gk08cU08cU07YE07YE06U.06U.05Qk/5Qk/5MU/4MU/4ME/3IE/"
E3E8"3IE/2E./2E./2Ak.1Ak.1AU.06U.06U./2E./2E./2EE/3IE/3IE./2E./2E."
E425"xnDzwnDzwXDysXDysXDxoHDxoHDxk1Dwk1DwknCvgnCvgnCucXCucXCtYHCtY"
E462"HCsU1CsU1CrQnBrQnBqMXBqMHBpIHBpE1BoE1BnAnAn6XAm6HAl2HAk.1Akwm"
E49F"9jsW9ioG9hk09fgW8eY08bMG7YAW6V.d5EB3iNadXMjPaNes/1BY97ul1/2sy"
E4DC"Na7REgP/.smpa92gUMC6PVp5D1d94P./.wj99u/..smVS6..iYc5..U97ul1/"
E519"2skNad97u/5/gymE81kiMc/2..a9LpWgvV1TgcF6Ae..gcFAAe0/gcF8A8..A"
E556"u1/gcL4Yc5A3k.1D85/wFL8X..AWwmsOE.9LpWgjcF6gXF4Ab/n.QL8H..s4."
E593".fTzvQ42.3X/J/IQ6I3ElnEJ.3b1J/IgDI3El1FJ.3X2J/IQII3ElPFJ.3b4J"
E5D0"/IwPI3ElpFJ.3X5J/IwTI3El2GJ.3z6J/6VW0...o/"
E100 B8 0 3C BA 65 1 33 C9 CD "!rC" BE 0 2 50 BD FB 2 55 BF 88 90
E117 "W3" DB B1 FA 8A F0 80 C1 6 32 E4 AC "<9v" 8 "<Zv" 2 2C 6 2C
E12F 7 2C 2E E3 E8 D3 E0 A C6 AA 2 D8 92 "IIMu" E0 80 FB 0 75 9 5A
E147 59 5B B4 40 CD 21 73 7 B4 9 BA 58 1 CD 21 CD 20 7 "Error!$"
G
Q

        That is all.  This program is very big, so take your time
putting it together.  After posting this program, I re-downloaded
all of the messages and combined them just to make sure they were
uploaded correctly, so they will hopefully make it out to the inner
recesses of the FidoNET intact...

        I have spent _many_ months optimizing my MOD playing
algorithms so they would be efficient enough to do in almost all
QB.  On my 286/10, I've rated it to use about 95% processor time at
11,000 hertz.  This may not sound like much, but the all-assembler
version of this algorithm(which is used in my first demo that we
will be releasing under Renaissance) is extremely efficient - it can
play any MOD up to 65,535 hertz on my 286/10 (and still have about
25% processor time remaining!).  This test was done on my Tandy's
DMA DAC, which can play at very high sample rates.

        As I said in QBMP15.BAS, I currently have not been able to
test this program in QuickBASIC 4.5, only PDS.

        Have fun!

        Rich Geldreich

    PS. Some of the docs in the QB program wrapped, so be carefull
reconstucted the code.

--- MsgToss 2.0b
 * Origin: Computer Co-Op - Voorhees, NJ | Ted Hare (1:266/29)